home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / vm / vm-virtual.el.z / vm-virtual.el
Encoding:
Text File  |  1998-05-21  |  26.3 KB  |  732 lines
  1. ;;; Virtual folders for VM
  2. ;;; Copyright (C) 1990-1997 Kyle E. Jones
  3. ;;;
  4. ;;; This program is free software; you can redistribute it and/or modify
  5. ;;; it under the terms of the GNU General Public License as published by
  6. ;;; the Free Software Foundation; either version 1, or (at your option)
  7. ;;; any later version.
  8. ;;;
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU General Public License
  15. ;;; along with this program; if not, write to the Free Software
  16. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17.  
  18. (provide 'vm-virtual)
  19.  
  20. (defun vm-build-virtual-message-list (new-messages &optional dont-finalize)
  21.   "Builds a list of messages matching the virtual folder definition
  22. stored in the variable vm-virtual-folder-definition.
  23.  
  24. If the NEW-MESSAGES argument is nil, the message list is
  25. derived from the folders listed in the virtual folder
  26. definition and selected by the various selectors.  The
  27. resulting message list is assigned to vm-message-list unless
  28. DONT-FINALIZE is non-nil.
  29.  
  30. If NEW-MESSAGES is non-nil then it is a list of messages to
  31. be tried against the selector parts of the virtual folder
  32. definition.  Matching messages are added to vm-message-list,
  33. instead of replacing it.
  34.  
  35. The messages in the NEW-MESSAGES list, if any, must all be in the
  36. same real folder.
  37.  
  38. The list of matching virtual messages is returned.
  39.  
  40. If DONT-FINALIZE is nil, in addition to vm-message-list being
  41. set, the virtual messages are added to the virtual message
  42. lists of their real messages, the current buffer is added to
  43. vm-virtual-buffers list of each real folder buffer represented
  44. in the virtual list, and vm-real-buffers is set to a list of
  45. all the real folder buffers involved."
  46.   (let ((clauses (cdr vm-virtual-folder-definition))
  47.     (message-set (make-vector 311 0))
  48.     (vbuffer (current-buffer))
  49.     (mirrored vm-virtual-mirror)
  50.     (case-fold-search t)
  51.     (tail-cons (if dont-finalize nil (vm-last vm-message-list)))
  52.     (new-message-list nil)
  53.     virtual location-vector
  54.     message mp folders folder
  55.     selectors sel-list selector arglist i
  56.     real-buffers-used)
  57.     (if dont-finalize
  58.     nil
  59.       ;; Since there is at most one virtual message in the folder
  60.       ;; buffer of a virtual folder, the location data vector (and
  61.       ;; the markers in it) of all virtual messages in a virtual
  62.       ;; folder is shared.  We initialize the vector here if it
  63.       ;; hasn't been created already.
  64.       (if vm-message-list
  65.       (setq location-vector
  66.         (vm-location-data-of (car vm-message-pointer)))
  67.     (setq i 0
  68.           location-vector
  69.           (make-vector vm-location-data-vector-length nil))
  70.     (while (< i vm-location-data-vector-length)
  71.       (aset location-vector i (vm-marker nil))
  72.       (vm-increment i)))
  73.       ;; To keep track of the messages in a virtual folder to
  74.       ;; prevent duplicates we create and maintain a set that
  75.       ;; contain all the real messages.
  76.       (setq mp vm-message-list)
  77.       (while mp
  78.     (intern (vm-message-id-number-of (vm-real-message-of (car mp)))
  79.         message-set)
  80.     (setq mp (cdr mp))))
  81.     ;; now select the messages
  82.     (save-excursion
  83.       (while clauses
  84.     (setq folders (car (car clauses))
  85.           selectors (cdr (car clauses)))
  86.     (while folders
  87.       (setq folder (car folders))
  88.       (and (stringp folder)
  89.            (setq folder (expand-file-name folder vm-folder-directory)))
  90.       (and (listp folder)
  91.            (setq folder (eval folder)))
  92.       (cond
  93.        ((null folder)
  94.         ;; folder was a s-expr which returned nil
  95.         ;; skip it
  96.         nil )
  97.        ((and (stringp folder) (file-directory-p folder))
  98.         (setq folders (nconc folders
  99.                  (vm-delete-backup-file-names
  100.                   (vm-delete-auto-save-file-names
  101.                    (vm-delete-directory-file-names
  102.                     (directory-files folder t nil)))))))
  103.        ((or (null new-messages)
  104.         ;; If we're assimilating messages into an
  105.         ;; existing virtual folder, only allow selectors
  106.         ;; that would be normally applied to this folder.
  107.         (and (bufferp folder)
  108.              (eq (vm-buffer-of (car new-messages)) folder))
  109.         (and (stringp folder)
  110.              (eq (vm-buffer-of (car new-messages))
  111.              ;; letter bomb protection
  112.              ;; set inhibit-local-variables to t for v18 Emacses
  113.              ;; set enable-local-variables to nil
  114.              ;; for newer Emacses
  115.              (let ((inhibit-local-variables t)
  116.                    (enable-local-variables nil))
  117.                (find-file-noselect folder)))))
  118.         (set-buffer (or (and (bufferp folder) folder)
  119.                 (vm-get-file-buffer folder)
  120.                 (let ((inhibit-local-variables t)
  121.                   (enable-local-variables nil))
  122.                   (find-file-noselect folder))))
  123.         (if (eq major-mode 'vm-virtual-mode)
  124.         (setq virtual t
  125.               real-buffers-used
  126.               (append vm-real-buffers real-buffers-used))
  127.           (setq virtual nil)
  128.           (if (not (memq (current-buffer) real-buffers-used))
  129.           (setq real-buffers-used (cons (current-buffer)
  130.                         real-buffers-used)))
  131.           (if (not (eq major-mode 'vm-mode))
  132.           (vm-mode)))
  133.         ;; change (sexpr) into ("/file" "/file2" ...)
  134.         ;; this assumes that there will never be (sexpr sexpr2)
  135.         ;; in a virtual folder spec.
  136.         (if (bufferp folder)
  137.         (if virtual
  138.             (setcar (car clauses)
  139.                 (delq nil
  140.                   (mapcar 'buffer-file-name vm-real-buffers)))
  141.           (if buffer-file-name
  142.               (setcar (car clauses) (list buffer-file-name)))))
  143.         ;; if new-messages non-nil use it instead of the
  144.         ;; whole message list
  145.         (setq mp (or new-messages vm-message-list))
  146.         (while mp
  147.           (if (and (or dont-finalize
  148.                (not (intern-soft
  149.                  (vm-message-id-number-of
  150.                   (vm-real-message-of (car mp)))
  151.                  message-set)))
  152.                (if virtual
  153.                (save-excursion
  154.                  (set-buffer
  155.                   (vm-buffer-of
  156.                    (vm-real-message-of
  157.                 (car mp))))
  158.                  (apply 'vm-vs-or (car mp) selectors))
  159.              (apply 'vm-vs-or (car mp) selectors)))
  160.           (progn
  161.             (or dont-finalize
  162.             (intern
  163.              (vm-message-id-number-of
  164.               (vm-real-message-of (car mp)))
  165.              message-set))
  166.             (setq message (copy-sequence
  167.                    (vm-real-message-of (car mp))))
  168.             (if mirrored
  169.             ()
  170.               (vm-set-mirror-data-of
  171.                message
  172.                (make-vector vm-mirror-data-vector-length nil))
  173.               (vm-set-virtual-messages-sym-of
  174.                message (make-symbol "<v>"))
  175.               (vm-set-virtual-messages-of message nil)
  176.               (vm-set-attributes-of
  177.                message
  178.                (make-vector vm-attributes-vector-length nil)))
  179.             (vm-set-location-data-of message location-vector)
  180.             (vm-set-softdata-of
  181.              message
  182.              (make-vector vm-softdata-vector-length nil))
  183.             (vm-set-real-message-sym-of
  184.              message
  185.              (vm-real-message-sym-of (car mp)))
  186.             (vm-set-message-type-of message vm-folder-type)
  187.             (vm-set-message-id-number-of message
  188.                          vm-message-id-number)
  189.             (vm-increment vm-message-id-number)
  190.             (vm-set-buffer-of message vbuffer)
  191.             (vm-set-reverse-link-sym-of message (make-symbol "<--"))
  192.             (vm-set-reverse-link-of message tail-cons)
  193.             (if (null tail-cons)
  194.             (setq new-message-list (list message)
  195.                   tail-cons new-message-list)
  196.               (setcdr tail-cons (list message))
  197.               (if (null new-message-list)
  198.               (setq new-message-list (cdr tail-cons)))
  199.               (setq tail-cons (cdr tail-cons)))))
  200.           (setq mp (cdr mp)))))
  201.       (setq folders (cdr folders)))
  202.     (setq clauses (cdr clauses))))
  203.     (if dont-finalize
  204.     new-message-list
  205.       ;; this doesn't need to work currently, but it might someday
  206.       ;; (if virtual
  207.       ;;    (setq real-buffers-used (vm-delete-duplicates real-buffers-used)))
  208.       (vm-increment vm-modification-counter)
  209.       ;; Until this point the user doesn't really have a virtual
  210.       ;; folder, as the virtual messages haven't been linked to the
  211.       ;; real messages, virtual buffers to the real buffers, and no
  212.       ;; message list has been installed.
  213.       ;;
  214.       ;; Now we tie it all together, with this section of code being
  215.       ;; uninterruptible.
  216.       (let ((inhibit-quit t)
  217.         (label-obarray vm-label-obarray))
  218.     (if (null vm-real-buffers)
  219.         (setq vm-real-buffers real-buffers-used))
  220.     (save-excursion
  221.       (while real-buffers-used
  222.         (set-buffer (car real-buffers-used))
  223.         ;; inherit the global label lists of all the associated
  224.         ;; real folders.
  225.         (mapatoms (function (lambda (x) (intern (symbol-name x)
  226.                             label-obarray)))
  227.               vm-label-obarray)
  228.         (if (not (memq vbuffer vm-virtual-buffers))
  229.         (setq vm-virtual-buffers (cons vbuffer vm-virtual-buffers)))
  230.         (setq real-buffers-used (cdr real-buffers-used))))
  231.     (setq mp new-message-list)
  232.     (while mp
  233.       (vm-set-virtual-messages-of
  234.        (vm-real-message-of (car mp))
  235.        (cons (car mp) (vm-virtual-messages-of (car mp))))
  236.       (setq mp (cdr mp)))
  237.     (if vm-message-list
  238.         (progn
  239.           (vm-set-summary-redo-start-point new-message-list)
  240.           (vm-set-numbering-redo-start-point new-message-list))
  241.       (vm-set-summary-redo-start-point t)
  242.       (vm-set-numbering-redo-start-point t)
  243.       (setq vm-message-list new-message-list))
  244.     new-message-list ))))
  245.  
  246. (defun vm-create-virtual-folder (selector &optional arg read-only name)
  247.   "Create a new virtual folder from messages in the current folder.
  248. The messages will be chosen by applying the selector you specify,
  249. which is normally read from the minibuffer.
  250.  
  251. Prefix arg means the new virtual folder should be visited read only."
  252.   (interactive
  253.    (let ((last-command last-command)
  254.      (this-command this-command)
  255.      (prefix current-prefix-arg))
  256.      (vm-select-folder-buffer)
  257.      (nconc (vm-read-virtual-selector "Create virtual folder of messages: ")
  258.         (list prefix))))
  259.   (vm-select-folder-buffer)
  260.   (vm-check-for-killed-summary)
  261.   (vm-error-if-folder-empty)
  262.   (let (vm-virtual-folder-alist)
  263.     (if (null name)
  264.     (if arg
  265.         (setq name (format "%s %s %s" (buffer-name) selector arg))
  266.       (setq name (format "%s %s" (buffer-name) selector))))
  267.     (setq vm-virtual-folder-alist
  268.       (list
  269.        (list name
  270.          (list (list (list 'get-buffer (buffer-name)))
  271.                (if arg (list selector arg) (list selector))))))
  272.     (vm-visit-virtual-folder name read-only))
  273.   ;; have to do this again here because the known virtual
  274.   ;; folder menu is now hosed because we installed it while
  275.   ;; vm-virtual-folder-alist was bound to the temp value above
  276.   (if vm-use-menus
  277.       (vm-menu-install-known-virtual-folders-menu)))
  278.  
  279.  
  280. (defun vm-apply-virtual-folder (name &optional read-only)
  281.   "Apply the selectors of a named virtual folder to the current folder
  282. and create a virtual folder containing the selected messages.
  283.  
  284. Prefix arg means the new virtual folder should be visited read only."
  285.   (interactive
  286.    (let ((last-command last-command)
  287.      (this-command this-command))
  288.      (list
  289.       (completing-read "Apply this virtual folder's selectors: "
  290.                vm-virtual-folder-alist nil t)
  291.       current-prefix-arg)))
  292.   (vm-select-folder-buffer)
  293.   (vm-check-for-killed-summary)
  294.   (vm-error-if-folder-empty)
  295.   (let ((vfolder (assoc name vm-virtual-folder-alist))
  296.     clauses vm-virtual-folder-alist)
  297.     (or vfolder (error "No such virtual folder, %s" name))
  298.     (setq vfolder (vm-copy vfolder))
  299.     (setq clauses (cdr vfolder))
  300.     (while clauses
  301.       (setcar (car clauses) (list (list 'get-buffer (buffer-name))))
  302.       (setq clauses (cdr clauses)))
  303.     (setcar vfolder (format "%s/%s" (buffer-name) (car vfolder)))
  304.     (setq vm-virtual-folder-alist (list vfolder))
  305.     (vm-visit-virtual-folder (car vfolder) read-only))
  306.   ;; have to do this again here because the "known virtual
  307.   ;; folder" menu is now hosed because we installed it while
  308.   ;; vm-virtual-folder-alist was bound to the temp value above
  309.   (if vm-use-menus
  310.       (vm-menu-install-known-virtual-folders-menu)))
  311.  
  312. (defun vm-create-virtual-folder-same-subject ()
  313.   (interactive)
  314.   (vm-follow-summary-cursor)
  315.   (vm-select-folder-buffer)
  316.   (vm-error-if-folder-empty)
  317.   (vm-check-for-killed-summary)
  318.   (vm-create-virtual-folder
  319.    'subject
  320.    (regexp-quote (vm-so-sortable-subject (car vm-message-pointer)))
  321.    nil
  322.    (format "%s %s %s" (buffer-name) 'subject
  323.        (vm-so-sortable-subject (car vm-message-pointer)))))
  324.  
  325. (defun vm-create-virtual-folder-same-author ()
  326.   (interactive)
  327.   (vm-follow-summary-cursor)
  328.   (vm-select-folder-buffer)
  329.   (vm-error-if-folder-empty)
  330.   (vm-check-for-killed-summary)
  331.   (vm-create-virtual-folder
  332.    'author
  333.    (regexp-quote (vm-su-from (car vm-message-pointer)))
  334.    nil
  335.    (format "%s %s %s" (buffer-name) 'author
  336.        (vm-su-from (car vm-message-pointer)))))
  337.  
  338. (defun vm-toggle-virtual-mirror ()
  339.   (interactive)
  340.   (vm-select-folder-buffer)
  341.   (vm-check-for-killed-summary)
  342.   (if (not (eq major-mode 'vm-virtual-mode))
  343.       (error "This is not a virtual folder."))
  344.   (let ((mp vm-message-list)
  345.     (inhibit-quit t)
  346.     modified undo-list)
  347.     (setq undo-list vm-saved-undo-record-list
  348.       vm-saved-undo-record-list vm-undo-record-list
  349.       vm-undo-record-list undo-list
  350.       vm-undo-record-pointer undo-list)
  351.     (setq modified vm-saved-buffer-modified-p
  352.       vm-saved-buffer-modified-p (buffer-modified-p))
  353.     (set-buffer-modified-p modified)
  354.     (if vm-virtual-mirror
  355.     (while mp
  356.       (vm-set-attributes-of
  357.        (car mp) (or (vm-saved-virtual-attributes-of (car mp))
  358.             (make-vector vm-attributes-vector-length nil)))
  359.       (vm-set-mirror-data-of
  360.        (car mp) (or (vm-saved-virtual-mirror-data-of (car mp))
  361.             (make-vector vm-mirror-data-vector-length nil)))
  362.       (vm-mark-for-summary-update (car mp) t)
  363.       (setq mp (cdr mp)))
  364.       (while mp
  365.     ;; mark for summary update _before_ we set this message to
  366.     ;; be mirrored.  this will prevent the real message and
  367.     ;; the other messages that will share attributes with
  368.     ;; this message from having their summaries
  369.     ;; updated... they don't need it.
  370.     (vm-mark-for-summary-update (car mp) t)
  371.     (vm-set-saved-virtual-attributes-of
  372.      (car mp) (vm-attributes-of (car mp)))
  373.     (vm-set-saved-virtual-mirror-data-of
  374.      (car mp) (vm-mirror-data-of (car mp)))
  375.     (vm-set-attributes-of
  376.      (car mp) (vm-attributes-of (vm-real-message-of (car mp))))
  377.     (vm-set-mirror-data-of
  378.      (car mp) (vm-mirror-data-of (vm-real-message-of (car mp))))
  379.     (setq mp (cdr mp))))
  380.     (setq vm-virtual-mirror (not vm-virtual-mirror))
  381.     (vm-increment vm-modification-counter))
  382.   (vm-update-summary-and-mode-line)
  383.   (message "Virtual folder now %s the underlying real folder%s."
  384.        (if vm-virtual-mirror "mirrors" "does not mirror")
  385.        (if (cdr vm-real-buffers) "s" "")))
  386.  
  387. (defun vm-virtual-help ()
  388.   (interactive)
  389.   (vm-display nil nil '(vm-virtual-help) '(vm-virtual-help))
  390.   (message "VV = visit, VX = apply selectors, VC = create, VM = toggle virtual mirror"))
  391.  
  392. (defun vm-vs-or (m &rest selectors)
  393.   (let ((result nil) selector arglist)
  394.     (while selectors
  395.       (setq selector (car (car selectors))
  396.         arglist (cdr (car selectors))
  397.         result (apply (cdr (assq selector
  398.                      vm-virtual-selector-function-alist))
  399.               m arglist)
  400.         selectors (if result nil (cdr selectors))))
  401.     result ))
  402.  
  403. (defun vm-vs-and (m &rest selectors)
  404.   (let ((result t) selector arglist)
  405.     (while selectors
  406.       (setq selector (car (car selectors))
  407.         arglist (cdr (car selectors))
  408.         result (apply (cdr (assq selector
  409.                      vm-virtual-selector-function-alist))
  410.               m arglist)
  411.         selectors (if (null result) nil (cdr selectors))))
  412.     result ))
  413.  
  414. (defun vm-vs-not (m arg)
  415.   (let ((selector (car arg))
  416.     (arglist (cdr arg)))
  417.     (not (apply (symbol-value selector) m arglist))))
  418.  
  419. (defun vm-vs-any (m) t)
  420.  
  421. (defun vm-vs-author (m arg)
  422.   (or (string-match arg (vm-su-full-name m))
  423.       (string-match arg (vm-su-from m))))
  424.  
  425. (fset 'vm-vs-sender 'vm-vs-author)
  426.  
  427. (defun vm-vs-recipient (m arg)
  428.   (or (string-match arg (vm-su-to m))
  429.       (string-match arg (vm-su-to-names m))))
  430.  
  431. (defun vm-vs-author-or-recipient (m arg)
  432.   (or (vm-vs-author m arg)
  433.       (vm-vs-recipient m arg)))
  434.  
  435. (fset 'vm-vs-sender-or-recipient 'vm-vs-author-or-recipient)
  436.  
  437. (defun vm-vs-subject (m arg)
  438.   (string-match arg (vm-su-subject m)))
  439.  
  440. (defun vm-vs-sent-before (m arg)
  441.   (string< (vm-so-sortable-datestring m) (vm-timezone-make-date-sortable arg)))
  442.  
  443. (defun vm-vs-sent-after (m arg)
  444.   (string< (vm-timezone-make-date-sortable arg) (vm-so-sortable-datestring m)))
  445.  
  446. (defun vm-vs-header (m arg)
  447.   (save-excursion
  448.     (save-restriction
  449.       (widen)
  450.       (goto-char (vm-headers-of (vm-real-message-of m)))
  451.       (re-search-forward arg (vm-text-of (vm-real-message-of m)) t))))
  452.  
  453. (defun vm-vs-label (m arg)
  454.   (vm-member arg (vm-labels-of m)))
  455.  
  456. (defun vm-vs-text (m arg)
  457.   (save-excursion
  458.     (save-restriction
  459.       (widen)
  460.       (goto-char (vm-text-of (vm-real-message-of m)))
  461.       (re-search-forward arg (vm-text-end-of (vm-real-message-of m)) t))))
  462.  
  463. (defun vm-vs-header-or-text (m arg)
  464.   (save-excursion
  465.     (save-restriction
  466.       (widen)
  467.       (goto-char (vm-headers-of (vm-real-message-of m)))
  468.       (re-search-forward arg (vm-text-end-of (vm-real-message-of m)) t))))
  469.  
  470. (defun vm-vs-more-chars-than (m arg)
  471.   (> (string-to-int (vm-su-byte-count m)) arg))
  472.  
  473. (defun vm-vs-less-chars-than (m arg)
  474.   (< (string-to-int (vm-su-byte-count m)) arg))
  475.  
  476. (defun vm-vs-more-lines-than (m arg)
  477.   (> (string-to-int (vm-su-line-count m)) arg))
  478.  
  479. (defun vm-vs-less-lines-than (m arg)
  480.   (< (string-to-int (vm-su-line-count m)) arg))
  481.  
  482. (defun vm-vs-new (m) (vm-new-flag m))
  483. (fset 'vm-vs-recent 'vm-vs-new)
  484. (defun vm-vs-unread (m) (vm-unread-flag m))
  485. (fset 'vm-vs-unseen 'vm-vs-unread)
  486. (defun vm-vs-read (m) (not (or (vm-new-flag m) (vm-unread-flag m))))
  487. (defun vm-vs-deleted (m) (vm-deleted-flag m))
  488. (defun vm-vs-replied (m) (vm-replied-flag m))
  489. (fset 'vm-vs-answered 'vm-vs-replied)
  490. (defun vm-vs-forwarded (m) (vm-forwarded-flag m))
  491. (defun vm-vs-redistributed (m) (vm-redistributed-flag m))
  492. (defun vm-vs-filed (m) (vm-filed-flag m))
  493. (defun vm-vs-written (m) (vm-written-flag m))
  494. (defun vm-vs-marked (m) (vm-mark-of m))
  495. (defun vm-vs-edited (m) (vm-edited-flag m))
  496.  
  497. (defun vm-vs-undeleted (m) (not (vm-deleted-flag m)))
  498. (defun vm-vs-unreplied (m) (not (vm-replied-flag m)))
  499. (fset 'vm-vs-unanswered 'vm-vs-unreplied)
  500. (defun vm-vs-unforwarded (m) (not (vm-forwarded-flag m)))
  501. (defun vm-vs-unredistributed (m) (not (vm-redistributed-flag m)))
  502. (defun vm-vs-unfiled (m) (not (vm-filed-flag m)))
  503. (defun vm-vs-unwritten (m) (not (vm-written-flag m)))
  504. (defun vm-vs-unmarked (m) (not (vm-mark-of m)))
  505. (defun vm-vs-unedited (m) (not (vm-edited-flag m)))
  506.  
  507. (put 'header 'vm-virtual-selector-clause "with header matching")
  508. (put 'label 'vm-virtual-selector-clause "with label of")
  509. (put 'text 'vm-virtual-selector-clause "with text matching")
  510. (put 'header-or-text 'vm-virtual-selector-clause
  511.      "with header or text matching")
  512. (put 'recipient 'vm-virtual-selector-clause "with recipient matching")
  513. (put 'author-or-recipient 'vm-virtual-selector-clause
  514.      "with author or recipient matching")
  515. (put 'sender-or-recipient 'vm-virtual-selector-clause
  516.      "with author or recipient matching")
  517. (put 'author 'vm-virtual-selector-clause "with author matching")
  518. (put 'sender 'vm-virtual-selector-clause "with author matching")
  519. (put 'subject 'vm-virtual-selector-clause "with subject matching")
  520. (put 'sent-before 'vm-virtual-selector-clause "sent before")
  521. (put 'sent-after 'vm-virtual-selector-clause "sent after")
  522. (put 'more-chars-than 'vm-virtual-selector-clause
  523.      "with more characters than")
  524. (put 'less-chars-than 'vm-virtual-selector-clause
  525.      "with less characters than")
  526. (put 'more-lines-than 'vm-virtual-selector-clause "with more lines than")
  527. (put 'less-lines-than 'vm-virtual-selector-clause "with less lines than")
  528. (put 'header 'vm-virtual-selector-arg-type 'string)
  529. (put 'label 'vm-virtual-selector-arg-type 'label)
  530. (put 'text 'vm-virtual-selector-arg-type 'string)
  531. (put 'header-or-text 'vm-virtual-selector-arg-type 'string)
  532. (put 'recipient 'vm-virtual-selector-arg-type 'string)
  533. (put 'author-or-recipient 'vm-virtual-selector-arg-type 'string)
  534. (put 'sender-or-recipient 'vm-virtual-selector-arg-type 'string)
  535. (put 'author 'vm-virtual-selector-arg-type 'string)
  536. (put 'sender 'vm-virtual-selector-arg-type 'string)
  537. (put 'subject 'vm-virtual-selector-arg-type 'string)
  538. (put 'sent-before 'vm-virtual-selector-arg-type 'string)
  539. (put 'sent-after 'vm-virtual-selector-arg-type 'string)
  540. (put 'more-chars-than 'vm-virtual-selector-arg-type 'number)
  541. (put 'less-chars-than 'vm-virtual-selector-arg-type 'number)
  542. (put 'more-lines-than 'vm-virtual-selector-arg-type 'number)
  543. (put 'less-lines-than 'vm-virtual-selector-arg-type 'number)
  544.  
  545. (defun vm-read-virtual-selector (prompt)
  546.   (let (selector (arg nil))
  547.     (setq selector
  548.       (vm-read-string prompt vm-supported-interactive-virtual-selectors)
  549.       selector (intern selector))
  550.     (let ((arg-type (get selector 'vm-virtual-selector-arg-type)))
  551.       (if (null arg-type)
  552.       nil
  553.     (setq prompt (concat (substring prompt 0 -2) " "
  554.                  (get selector 'vm-virtual-selector-clause)
  555.                  ": "))
  556.     (raise-frame (selected-frame))
  557.     (cond ((eq arg-type 'number)
  558.            (setq arg (vm-read-number prompt)))
  559.           ((eq arg-type 'label)
  560.            (let ((vm-completion-auto-correct nil)
  561.              (completion-ignore-case t))
  562.          (setq arg (downcase
  563.                 (vm-read-string
  564.                  prompt
  565.                  (vm-obarray-to-string-list
  566.                   vm-label-obarray)
  567.                  nil)))))
  568.           (t (setq arg (read-string prompt))))))
  569.     (or (fboundp (intern (concat "vm-vs-" (symbol-name selector))))
  570.     (error "Invalid selector"))
  571.     (list selector arg)))
  572.  
  573. ;; clear away links between real and virtual folders when
  574. ;; a vm-quit is performed in either type folder.
  575. (defun vm-virtual-quit ()
  576.   (save-excursion
  577.     (cond ((eq major-mode 'vm-virtual-mode)
  578.        ;; don't trust blindly, user might have killed some of
  579.        ;; these buffers.
  580.        (setq vm-real-buffers (vm-delete 'buffer-name vm-real-buffers t))
  581.        (let ((bp vm-real-buffers)
  582.          (mp vm-message-list)
  583.          (b (current-buffer))
  584.          ;; lock out interrupts here
  585.          (inhibit-quit t))
  586.          (while bp
  587.            (set-buffer (car bp))
  588.            (setq vm-virtual-buffers (delq b vm-virtual-buffers)
  589.              bp (cdr bp)))
  590.          (while mp
  591.            (vm-set-virtual-messages-of
  592.         (vm-real-message-of (car mp))
  593.         (delq (car mp) (vm-virtual-messages-of
  594.                 (vm-real-message-of (car mp)))))
  595.            (setq mp (cdr mp)))))
  596.       ((eq major-mode 'vm-mode)
  597.        ;; don't trust blindly, user might have killed some of
  598.        ;; these buffers.
  599.        (setq vm-virtual-buffers
  600.          (vm-delete 'buffer-name vm-virtual-buffers t))
  601.        (let ((bp vm-virtual-buffers)
  602.          (mp vm-message-list)
  603.          vmp
  604.          (b (current-buffer))
  605.          ;; lock out interrupts here
  606.          (inhibit-quit t))
  607.          (while mp
  608.            (setq vmp (vm-virtual-messages-of (car mp)))
  609.            (while vmp
  610.          ;; we'll clear these messages from the virtual
  611.          ;; folder by looking for messages that have a "Q"
  612.          ;; id number associated with them.
  613.          (vm-set-message-id-number-of (car vmp) "Q")
  614.          (setq vmp (cdr vmp)))
  615.            (vm-set-virtual-messages-of (car mp) nil)
  616.            (setq mp (cdr mp)))
  617.          (while bp
  618.            (set-buffer (car bp))
  619.            (setq vm-real-buffers (delq b vm-real-buffers))
  620.            ;; set the message pointer to a new value if it is
  621.            ;; now invalid.
  622.            (cond
  623.         ((and vm-message-pointer
  624.               (equal "Q" (vm-message-id-number-of
  625.                   (car vm-message-pointer))))
  626.          (vm-garbage-collect-message)
  627.          (setq vmp vm-message-pointer)
  628.          (while (and vm-message-pointer
  629.                  (equal "Q" (vm-message-id-number-of
  630.                      (car vm-message-pointer))))
  631.            (setq vm-message-pointer
  632.              (cdr vm-message-pointer)))
  633.          ;; if there were no good messages ahead, try going
  634.          ;; backward.
  635.          (if (null vm-message-pointer)
  636.              (progn
  637.                (setq vm-message-pointer vmp)
  638.                (while (and vm-message-pointer
  639.                    (equal "Q" (vm-message-id-number-of
  640.                            (car vm-message-pointer))))
  641.              (setq vm-message-pointer
  642.                    (vm-reverse-link-of
  643.                 (car vm-message-pointer))))))))
  644.            ;; expunge the virtual messages associated with
  645.            ;; real messages that are going away.
  646.            (setq vm-message-list
  647.              (vm-delete (function
  648.                  (lambda (m)
  649.                    (equal "Q" (vm-message-id-number-of m))))
  650.                 vm-message-list nil))
  651.            (if (null vm-message-pointer)
  652.            (setq vm-message-pointer vm-message-list))
  653.            ;; same for vm-last-message-pointer
  654.            (if (null vm-last-message-pointer)
  655.            (setq vm-last-message-pointer nil))
  656.            (vm-clear-virtual-quit-invalidated-undos)
  657.            (vm-reverse-link-messages)
  658.            (vm-set-numbering-redo-start-point t)
  659.            (vm-set-summary-redo-start-point t)
  660.            (if vm-message-pointer
  661.            (vm-preview-current-message)
  662.          (vm-update-summary-and-mode-line))
  663.            (setq bp (cdr bp))))))))
  664.  
  665. (defun vm-virtual-save-folder (prefix)
  666.   (save-excursion
  667.     ;; don't trust blindly, user might have killed some of
  668.     ;; these buffers.
  669.     (setq vm-real-buffers (vm-delete 'buffer-name vm-real-buffers t))
  670.     (let ((bp vm-real-buffers))
  671.       (while bp
  672.     (set-buffer (car bp))
  673.     (vm-save-folder prefix)
  674.     (setq bp (cdr bp)))))
  675.   (vm-set-buffer-modified-p nil)
  676.   (vm-clear-modification-flag-undos)
  677.   (vm-update-summary-and-mode-line))
  678.  
  679. (defun vm-virtual-get-new-mail ()
  680.   (save-excursion
  681.     ;; don't trust blindly, user might have killed some of
  682.     ;; these buffers.
  683.     (setq vm-real-buffers (vm-delete 'buffer-name vm-real-buffers t))
  684.     (let ((bp vm-real-buffers))
  685.       (while bp
  686.     (set-buffer (car bp))
  687.     (condition-case error-data
  688.         (vm-get-new-mail)
  689.       (folder-read-only
  690.        (message "Folder is read only: %s"
  691.             (or buffer-file-name (buffer-name)))
  692.        (sit-for 1))
  693.       (unrecognized-folder-type
  694.        (message "Folder type is unrecognized: %s"
  695.             (or buffer-file-name (buffer-name)))
  696.        (sit-for 1)))
  697.     (setq bp (cdr bp)))))
  698.   (vm-emit-totals-blurb))
  699.  
  700. (defun vm-make-virtual-copy (m)
  701.   (widen)
  702.   (let ((virtual-buffer (current-buffer))
  703.     (real-m (vm-real-message-of m))
  704.     (buffer-read-only nil)
  705.     (modified (buffer-modified-p)))
  706.     (unwind-protect
  707.     (save-excursion
  708.       (set-buffer (vm-buffer-of real-m))
  709.       (save-restriction
  710.         (widen)
  711.         ;; must reference this now so that headers will be in
  712.         ;; their final position before the message is copied.
  713.         ;; otherwise the vheader offset computed below will be wrong.
  714.         (vm-vheaders-of real-m)
  715.         (copy-to-buffer virtual-buffer (vm-start-of real-m)
  716.                 (vm-end-of real-m))))
  717.       (set-buffer-modified-p modified))
  718.     (set-marker (vm-start-of m) (point-min))
  719.     (set-marker (vm-headers-of m) (+ (vm-start-of m)
  720.                      (- (vm-headers-of real-m)
  721.                     (vm-start-of real-m))))
  722.     (set-marker (vm-vheaders-of m) (+ (vm-start-of m)
  723.                       (- (vm-vheaders-of real-m)
  724.                      (vm-start-of real-m))))
  725.     (set-marker (vm-text-of m) (+ (vm-start-of m) (- (vm-text-of real-m)
  726.                              (vm-start-of real-m))))
  727.     (set-marker (vm-text-end-of m) (+ (vm-start-of m)
  728.                       (- (vm-text-end-of real-m)
  729.                      (vm-start-of real-m))))
  730.     (set-marker (vm-end-of m) (+ (vm-start-of m) (- (vm-end-of real-m)
  731.                             (vm-start-of real-m))))))
  732.